home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / vector.t < prev    next >
Text File  |  1988-02-05  |  8KB  |  214 lines
  1. (herald vector (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; the size is converted to the number of longwords needed, represented as a
  27. ;;; t integer.  coincidentally (?) this is the number of longwords * 4 or
  28. ;;; the number of bytes to cons. we add 4 bytes for the header in size computation.
  29. ;;; vector types are limited to 23 bits for the number of elements
  30.  
  31. ;(define-constant MAXIMUM-VECTOR-SIZE (fx- (fixnum-ashl 1 24) 1)) ; bootstrap?!
  32.                                                                 
  33. ;;; the MAXIMUM-VECTOR-SIZE is 23 bits.
  34. (define-constant (acceptable-vector-size? i)   
  35.   (and (fixnum? i) (fx>= i 0) (fx<= i 16777215)))
  36.  
  37. (define (make-bytev length)
  38.   (let ((length (enforce acceptable-vector-size? length)))
  39.     (make-vector-extend header/bytev length (fixnum-ashr (fx+ length 3) 2))))
  40.  
  41. (define (make-text length)
  42.   (let ((length (enforce acceptable-vector-size? length)))
  43.     (make-vector-extend header/text length (fixnum-ashr (fx+ length 3) 2))))
  44.  
  45. (define (make-vector length . fill)
  46.   (let ((vec (make-vector-extend header/general-vector
  47.                      (enforce acceptable-vector-size? length)
  48.                      length))
  49.         (fill (if (pair? fill) (car fill) '#f)))
  50.     (if fill (vector-fill vec fill))
  51.     vec))
  52.  
  53. (define (make-unit length)
  54.   (make-vector-extend header/unit
  55.                      (enforce acceptable-vector-size? length)
  56.                      length))
  57.  
  58. (define (make-vcell id)
  59.   (let ((v (make-vector-extend header/vcell 0 %%vcell-size)))
  60.     (set (mref-integer v 0) header/nonvalue)
  61.     (set (vcell-locations v) (make-weak-alist))
  62.     (set (vcell-vcell-locations v) (make-weak-alist))
  63.     (set (vcell-id v) id)
  64.     v))
  65.  
  66. (define (make-foreign name)
  67.   (let ((x (make-vector-extend header/foreign 0 2)))
  68.     (set (foreign-name x) name)
  69.     x))
  70.   
  71. (define (vector-replace target source len)
  72.   (let ((target (enforce vector? target))
  73.         (source (enforce vector? source))
  74.         (len (enforce nonnegative-fixnum? len)))
  75.     (%copy-extend target source len)))
  76.  
  77. (define (copy-vector vector)            
  78.   (%copy-vector (enforce vector? vector)))
  79.  
  80. (define (copy-bytev bytev)
  81.   (%copy-bytev (enforce bytev? bytev)))
  82.            
  83. (define (copy-text text)
  84.   (%copy-text (enforce text? text)))
  85.  
  86. (define (vector . elements) (list->vector elements))
  87.  
  88. (define (list->vector l)
  89.   (let ((l (enforce list? l)))
  90.   (let ((len (length l)))
  91.     (let ((vec (make-vector len)))
  92.       (do ((i 0 (fx+ i 1))
  93.            (l l (cdr l)))
  94.           ((fx= i len) vec)
  95.         (set (vref vec i) (car l)))))))
  96.  
  97. (define (vector->list v)
  98.   (let ((v (enforce vector? v)))
  99.     (do ((i (fx- (vector-length v) 1) (fx- i 1))
  100.          (l '() (cons (vref v i) l)))
  101.         ((fx< i 0) l))))
  102.  
  103. (define (vector-pos pred thing vector)
  104.   (let ((len (vector-length vector)))
  105.     (iterate loop ((i 0))
  106.       (cond ((fx>= i len) nil)
  107.             ((pred thing (vref vector i)) i)
  108.             (else (loop (fx+ i 1)))))))
  109.  
  110. (define-integrable (vector-posq thing vector) (vector-pos eq? thing vector))
  111.  
  112. (define (walk-vector fn vec)
  113.   (let ((vec (enforce vector? vec)))
  114.     (let ((limit (fx- (vector-length vec) 1)))
  115.       (cond ((fx>= limit 0)
  116.              (iterate loop ((i 0))
  117.                (cond ((fx>= i limit) 
  118.                       (fn (vref vec i)))
  119.                      (else
  120.                       (fn (vref vec i))
  121.                       (loop (fx+ i 1))))))))))
  122.  
  123.  
  124. (define (%copy-vector vector)
  125.   (let ((len (vector-length vector)))
  126.     (%copy-extend (make-vector len) vector len)))  
  127.  
  128. (define (%copy-bytev bytev)
  129.   (let ((len (bytev-length bytev)))
  130.     (%copy-extend (make-bytev len)
  131.                   bytev
  132.                   (fixnum-ashr (fx+ len 3) 2))))
  133.  
  134. (define (%copy-text text)
  135.   (let ((len (text-length text)))
  136.     (%copy-extend (make-text len)
  137.                   text
  138.                   (fixnum-ashr (fx+ len 3) 2))))
  139.  
  140. (define (%copy-extend dest source cells)
  141.   (do ((i 0 (fx+ i 1)))
  142.       ((fx= i cells) dest)
  143.     (set (extend-elt dest i) (extend-elt source i))))
  144.  
  145. (define (vector-fill vector value)      
  146.   (let ((size (vector-length vector)))  
  147.     (do ((i 0 (fx+ i 1)))
  148.         ((fx>= i size) vector)
  149.       (set (vref vector i) value))))
  150.  
  151. (define-handler general-vector
  152.   (object nil
  153.     ((hash self)
  154.      (do ((i 0 (fx+ i 1))
  155.           (h 0 (fx+ h (hash (vref self i)))))
  156.          ((fx>= h (vector-length self)) h)))
  157.     ((crawl-exhibit self)
  158.      (exhibit-standard-extend self (vector-length self) 0 0))
  159.     ((maybe-crawl-component self command)
  160.      (cond ((and (nonnegative-fixnum? command)
  161.                  (fx< command (vector-length self)))
  162.             (crawl-push (vref self command)))
  163.            (else nil)))
  164.     ((print obj port)
  165.      (write-char port *dispatch-char*)
  166.      (write-char port *list-begin-char*)
  167.      (iterate loop ((flag nil)
  168.                     (i 0))
  169.        (cond ((fx>= i (vector-length obj)))
  170.              (else
  171.               (if flag (space port))
  172.               (cond ((fx>= i *print-length*)
  173.                      (write-string port print-length-excess))
  174.                     (else
  175.                      (print (vref obj i) port)
  176.                      (loop t (fx+ i 1)))))))
  177.      (write-char port *list-end-char*))))
  178.  
  179. (define (*define-accessor name type offset)
  180.   (let ((the-setter (lambda (x v)
  181.               (let ((x (enforce type x)))
  182.             (set (extend-pointer-elt x offset) v)))))
  183.     (object (lambda (x)          
  184.           (let ((x (enforce type x)))
  185.         (extend-pointer-elt x offset)))
  186.       ((setter self) the-setter)
  187.       ((identification self) name))))
  188.  
  189. (define-operation (unguarded-accessor accessor))
  190.  
  191. (define (*define-vector-accessor name type fetch store)
  192.   (let ((the-setter (lambda (x i v)
  193.               (cond ((not (type x))
  194.                  (error "~s answered false to ~s" x (identification type)))
  195.                 ((or (fixnum-less? i 0)
  196.                  (fixnum-not-less? i (vector-length x)))
  197.                  (error "~s index out of range"
  198.                     (list 'set (list name x i) v)))
  199.                 (else
  200.                  (store x i v))))))
  201.     (object (lambda (x i)
  202.           (cond ((not (type x))
  203.              (error "~s answered false to ~s" x (identification type)))
  204.             ((or (fixnum-less? i 0)
  205.              (fixnum-not-less? i (vector-length x)))
  206.              (error "~s index out of range"
  207.                 (list name x i)))
  208.             (else
  209.              (fetch x i))))
  210.       ((setter self) the-setter)
  211.       ((identification self) name)
  212.       ((unguarded-accessor self) fetch))))
  213.  
  214.